home *** CD-ROM | disk | FTP | other *** search
/ FishMarket 1.0 / FishMarket v1.0.iso / fishies / 376-400 / disk_386 / xlispstat / src1.lzh / XLisp / xlsym.c < prev    next >
C/C++ Source or Header  |  1990-10-03  |  6KB  |  272 lines
  1. /* xlsym - symbol handling routines */
  2. /* Copyright (c) 1989, by David Michael Betz.                            */
  3. /* You may give out copies of this software; for conditions see the file */
  4. /* COPYING included with this distribution.                              */
  5.  
  6. #include <string.h>
  7. #include "xlisp.h"
  8. #include "osdef.h"
  9. #ifdef ANSI
  10. #include "xlproto.h"
  11. #include "xlsproto.h"
  12. #else
  13. #include "xlfun.h"
  14. #include "xlsfun.h"
  15. #endif ANSI
  16. #include "xlvar.h"
  17.  
  18. /* forward declarations */
  19. #ifdef ANSI
  20. LVAL findprop(LVAL,LVAL);
  21. #else
  22. LVAL findprop();
  23. #endif ANSI
  24.  
  25. /* xlenter - enter a symbol into the obarray */
  26. LVAL xlenter(name)
  27.   char *name;
  28. {
  29.     LVAL sym,array;
  30.     int i;
  31.  
  32.     /* check for nil */
  33.     if (strcmp(name,"NIL") == 0)
  34.     return (NIL);
  35.  
  36.     /* check for symbol already in table */
  37.     array = getvalue(obarray);
  38.     i = hash(name,HSIZE);
  39.     for (sym = getelement(array,i); sym; sym = cdr(sym))
  40.     if (strcmp(name,getstring(getpname(car(sym)))) == 0)
  41.         return (car(sym));
  42.  
  43.     /* make a new symbol node and link it into the list */
  44.     xlsave1(sym);
  45.     sym = consd(getelement(array,i));
  46.     rplaca(sym,xlmakesym(name));
  47.     setelement(array,i,sym);
  48.     xlpop();
  49.  
  50.     /* return the new symbol */
  51.     return (car(sym));
  52. }
  53.  
  54. /* xlmakesym - make a new symbol node */
  55. LVAL xlmakesym(name)
  56.   char *name;
  57. {
  58.     LVAL sym;
  59.     sym = cvsymbol(name);
  60.     if (*name == ':') {
  61.         setconstant(sym, TRUE); /* L. Tierney */
  62.     setvalue(sym,sym);
  63.     }
  64.     return (sym);
  65. }
  66.  
  67. /* xlgetvalue - get the value of a symbol (with check) */
  68. LVAL xlgetvalue(sym)
  69.   LVAL sym;
  70. {
  71.     LVAL val;
  72.  
  73.     /* look for the value of the symbol */
  74.     while ((val = xlxgetvalue(sym)) == s_unbound)
  75.     xlunbound(sym);
  76.  
  77.     /* return the value */
  78.     return (val);
  79. }
  80.  
  81. /* xlxgetvalue - get the value of a symbol */
  82. LVAL xlxgetvalue(sym)
  83.   LVAL sym;
  84. {
  85.     register LVAL fp,ep;
  86.     LVAL val;
  87.  
  88.     /* check the environment list */
  89.     for (fp = xlenv; fp; fp = cdr(fp))
  90.  
  91.     /* check for an instance variable */
  92.     if ((ep = car(fp)) && objectp(car(ep))) {
  93.         if (xlobgetvalue(ep,sym,&val))
  94.         return (val);
  95.     }
  96.  
  97.     /* check an environment stack frame */
  98.     else {
  99.         for (; ep; ep = cdr(ep))
  100.         if (sym == car(car(ep)))
  101.             return (cdr(car(ep)));
  102.     }
  103.  
  104.     /* return the global value */
  105.     return (getvalue(sym));
  106. }
  107.  
  108. /* xlsetvalue - set the value of a symbol */
  109. void xlsetvalue(sym,val)
  110.   LVAL sym,val;
  111. {
  112.     register LVAL fp,ep;
  113.  
  114.     /* look for the symbol in the environment list */
  115.     for (fp = xlenv; fp; fp = cdr(fp))
  116.  
  117.     /* check for an instance variable */
  118.     if ((ep = car(fp)) && objectp(car(ep))) {
  119.         if (xlobsetvalue(ep,sym,val))
  120.         return;
  121.     }
  122.  
  123.     /* check an environment stack frame */
  124.     else {
  125.         for (; ep; ep = cdr(ep))
  126.         if (sym == car(car(ep))) {
  127.             rplacd(car(ep),val);
  128.             return;
  129.         }
  130.     }
  131.  
  132.     /* store the global value */
  133.     setvalue(sym,val);
  134. }
  135.  
  136. /* xlgetfunction - get the functional value of a symbol (with check) */
  137. LVAL xlgetfunction(sym)
  138.   LVAL sym;
  139. {
  140.     LVAL val;
  141.  
  142.     /* look for the functional value of the symbol */
  143.     while ((val = xlxgetfunction(sym)) == s_unbound)
  144.     xlfunbound(sym);
  145.  
  146.     /* return the value */
  147.     return (val);
  148. }
  149.  
  150. /* xlxgetfunction - get the functional value of a symbol */
  151. LVAL xlxgetfunction(sym)
  152.   LVAL sym;
  153. {
  154.     register LVAL fp,ep;
  155.  
  156.     /* check the environment list */
  157.     for (fp = xlfenv; fp; fp = cdr(fp))
  158.     for (ep = car(fp); ep; ep = cdr(ep))
  159.         if (sym == car(car(ep)))
  160.         return (cdr(car(ep)));
  161.  
  162.     /* return the global value */
  163.     return (getfunction(sym));
  164. }
  165.  
  166. /* xlsetfunction - set the functional value of a symbol */
  167. void xlsetfunction(sym,val)
  168.   LVAL sym,val;
  169. {
  170.     register LVAL fp,ep;
  171.  
  172.     /* look for the symbol in the environment list */
  173.     for (fp = xlfenv; fp; fp = cdr(fp))
  174.     for (ep = car(fp); ep; ep = cdr(ep))
  175.         if (sym == car(car(ep))) {
  176.         rplacd(car(ep),val);
  177.         return;
  178.         }
  179.  
  180.     /* store the global value */
  181.     setfunction(sym,val);
  182. }
  183.  
  184. /* xlgetprop - get the value of a property */
  185. LVAL xlgetprop(sym,prp)
  186.   LVAL sym,prp;
  187. {
  188.     LVAL p;
  189.     return ((p = findprop(sym,prp)) ? car(p) : NIL);
  190. }
  191.  
  192. /* xlputprop - put a property value onto the property list */
  193. void xlputprop(sym,val,prp)
  194.   LVAL sym,val,prp;
  195. {
  196.     LVAL pair;
  197.     if (pair = findprop(sym,prp))
  198.     rplaca(pair,val);
  199.     else
  200.     setplist(sym,cons(prp,cons(val,getplist(sym))));
  201. }
  202.  
  203. /* xlremprop - remove a property from a property list */
  204. void xlremprop(sym,prp)
  205.   LVAL sym,prp;
  206. {
  207.     LVAL last,p;
  208.     last = NIL;
  209.     for (p = getplist(sym); consp(p) && consp(cdr(p)); p = cdr(last)) {
  210.     if (car(p) == prp)
  211.         if (last)
  212.         rplacd(last,cdr(cdr(p)));
  213.         else
  214.         setplist(sym,cdr(cdr(p)));
  215.     last = cdr(p);
  216.     }
  217. }
  218.  
  219. /* findprop - find a property pair */
  220. LOCAL LVAL findprop(sym,prp)
  221.   LVAL sym,prp;
  222. {
  223.     LVAL p;
  224.     for (p = getplist(sym); consp(p) && consp(cdr(p)); p = cdr(cdr(p)))
  225.     if (car(p) == prp)
  226.         return (cdr(p));
  227.     return (NIL);
  228. }
  229.  
  230. /* hash - hash a symbol name string */
  231. int hash(str,len)
  232.   char *str; int len;
  233. {
  234.     int i;
  235.     for (i = 0; *str; )
  236.     i = (i << 2) ^ *str++;
  237.     i %= len;
  238.     return (i < 0 ? -i : i);
  239. }
  240.  
  241. /* xlsinit - symbol initialization routine */
  242. void xlsinit()
  243. {
  244.     LVAL array,p;
  245.  
  246.     /* initialize the obarray */
  247.     obarray = xlmakesym("*OBARRAY*");
  248.     array = newvector(HSIZE);
  249.     setvalue(obarray,array);
  250.  
  251.     /* add the symbol *OBARRAY* to the obarray */
  252.     p = consa(obarray);
  253.     setelement(array,hash("*OBARRAY*",HSIZE),p);
  254. }
  255.  
  256. /* added - L. Tierney */
  257. int syminterned(sym)
  258.     LVAL sym;
  259. {
  260.   char *name;
  261.   LVAL list, array;
  262.   
  263.   name = (char *) getstring(getpname(sym));
  264.   array = getvalue(obarray);
  265.   list = getelement(array, hash(name, HSIZE));
  266.   
  267.   for (; consp(list); list = cdr(list))
  268.     if (sym == car(list)) return(TRUE);
  269.   return(FALSE);
  270. }
  271.  
  272.